(library (grid-gen main)
  (export  def-cache
           lam-cache
           obj-find-el

           in-list?

           int-err
           roll
           list-cut
           list-ins
           replace-el
           remove-duplicates
;;           unspecified?
;;           list-set!
;;           primitive-eval
;;           zip
;;           delete
           iota1
           inc
           dec
           
           iptr
           iptr2
           bnd2ij
           
           dbg-wr
           lck
           sym->str
           hash->assoc
           hash-reverse
           hash-keys
           hash-vals
           hash-copy

           assoc->hash

           lamx
           lamxx
           lamn
           lamln
           lameq
           lamneq
           lamcon
           lamapp
           pip
           
           wmt
           
           shdot
           
           dtim
           
;;           string-map
;;           string-join
           string-contains-only?
;;           string-split
           
           string-has?
           
;;           set-env!
;;           list-j12
;;           list-before
;;           list-split
;;           andmap
           
           PHYS:vrs:rpuvw
           PHYS:vrs:rhuvw
           PHYS:vrs:q
           PHYS:vrs-proj
           PHYS:vrs-bkproj
           PHYS:q
           PHYS:F
           PHYS:chrs
           PHYS:A
           PHYS:L
           PHYS:R
           PHYS:DS
           PHYS:qlen
           PHYS:vect
           PHYS:srcs
           PHYS:Potential

           ADV:dF
           ADV:dF1
           ADV:dFl
           ADV:vm
           ADV:lam
           
           MATH:simplify
           
           CODE:precision
           CODE:enable-SMP
           SMP:disable
           OpenMP:nproc
           
           set-presision

           comp-order
           set-comp-order
           
           mk-worm
           grid:cart
           grid:norm
           grid:join
           
           save-amb2
           restore-amb2
           amb2
           amb2-cond
           amb2-min
           with-amb2
  )

  (import ;(rnrs)
          ;(rnrs mutable-pairs)
          ;(rnrs eval)
          ;(chezscheme)
          (guile)
          (except (srfi srfi-1) map)
          (rnrs)
          (ice-9 threads)
;;          (statprof)
  )



(define andmap every)
(define ormap any)

(define cmp-order 1)

(define comp-order (lambda () cmp-order))

(define set-comp-order (lambda (n)
  (set! cmp-order n)
))

(define CODE:enable-SMP #f)
(define OpenMP:nproc #f)
(define SMP:disable)

(define ADV:dF (lambda ar (int-err "ADV:dF is not defined!")))
(define ADV:dF1 (lambda ar (int-err "ADV:dF1 is not defined!")))
(define ADV:dFl (lambda ar (int-err "ADV:dFl is not defined!")))
(define ADV:vm (lambda ar (int-err "ADV:vm is not defined!")))
(define ADV:lam (lambda ar (int-err "ADV:lam is not defined!")))

(define PHYS:vrs:rpuvw (lambda ar (int-err "PHYS:vrs:rpuvw is not defined!")))
(define PHYS:vrs:rhuvw (lambda ar (int-err "PHYS:vrs:rhuvw is not defined!")))
(define PHYS:vrs:q (lambda ar (int-err "PHYS:vrs:q is not defined!")))
(define PHYS:vrs-proj (lambda ar (int-err "PHYS:vrs-proj is not defined!")))
(define PHYS:vrs-bkproj (lambda ar (int-err "PHYS:vrs-bkproj is not defined!")))
(define PHYS:q (lambda ar (int-err "PHYS:q is not defined!")))
(define PHYS:F (lambda ar (int-err "PHYS:F is not defined!")))
(define PHYS:chrs (lambda ar (int-err "PHYS:chrs is not defined!")))
(define PHYS:A (lambda ar (int-err "PHYS:A is not defined!")))
(define PHYS:L (lambda ar (int-err "PHYS:L is not defined!")))
(define PHYS:R (lambda ar (int-err "PHYS:R is not defined!")))
(define PHYS:DS (lambda ar (int-err "PHYS:DS is not defined!")))
(define PHYS:qlen (lambda ar (int-err "PHYS:qlen is not defined!")))
(define PHYS:vect (lambda ar (int-err "PHYS:vect is not defined!")))
(define PHYS:vrs:swap (lambda ar (int-err "PHYS:vrs:swap is not defined!")))
(define PHYS:srcs (lambda ar (int-err "PHYS:srcs is not defined!")))
(define PHYS:Potential (lambda ar (int-err "PHYS:Potential is not defined!")))

(define grid:cart (lambda ar (int-err "grid:cart is not defined!")))
(define grid:norm (lambda ar (int-err "grid:norm is not defined!")))
(define grid:join (lambda ar (int-err "grid:join is not defined!")))

(define MATH:simplify (lambda (v) v))

(define CODE:precision 4)

(define set-presision (lambda (p) (set! CODE:precision p)))

(define-syntax dbg-wr
  (syntax-rules ()
    ((_ w1 w2 ex)
     (begin
       (format #t w1)
       (format #t "\n")
       (let ((r ex))
         (format #t w2)
         (format #t "\n")
         r
       )
     )
    )
  )
)

(define-syntax wmt
  (syntax-rules ()
    ((_ mtx ex)
     (with-mutex mtx
       ex
     )
    )
  )
)

(define dtim (lambda (s ex) ex))

;(define-syntax dtim
;  (syntax-rules ()
;    ((_ s ex)
;     (let* ((t0 (tms:clock (times)))
;            (r ex)
;           )
;       (format #t "\nTime (~a): ~a ms\n" s (- (tms:clock (times)) t0))
;       r
;     )
;    )
;  )
;)

(define sym-append (lambda (s1 s2)
  (string->symbol (string-append (symbol->string s1) s2))
))

(define lam-cache (lambda (lam)
  (let ((ch (make-hash-table))
        (fls (gensym))
       )
    (lambda args
      (let ((r (hash-ref ch args fls)))
        (if (eq? r fls)
            (let ((r1 (apply lam args)))
              (hash-set! ch args r1)
              r1
            )
            r
        )
      )
    )
  )
))

(define-macro (def-cache nam lam)
  (let* ((cn  (sym-append nam "-cache-h"))
         (fls (sym-append nam "-cache-fls"))
         (res (sym-append nam "-cache-res"))
         (cod `(begin
                 (define ,cn (make-hash-table))
                 (define ,nam
                   (lambda args
                     (let* ((,fls (lambda () #f))
                            (,res (hash-ref ,cn args ,fls))
                           )
                       (if (eq? ,res ,fls)
                           (let ((,res (apply ,lam args)))
                             (hash-set! ,cn args ,res)
                            ,res
                           )
                          ,res
                       )
                     )
                   )
                 )
               )
         )
        )
    cod
  )
)

(define last-amb #f)
(define amb-state (make-hash-table))
(define amb-best-state #f)
(define amb-best-scores #f)
(define amb-return-best #f)
(define amb-cnt 0)

(define save-amb2 (lambda ()
  (let ((r `(,last-amb ,amb-state ,amb-best-state ,amb-best-scores
             ,amb-return-best ,amb-cnt
            )
        )
       )
    (set! last-amb #f)
    (set! amb-state (make-hash-table))
    (set! amb-best-state #f)
    (set! amb-best-scores #f)
    (set! amb-return-best #f)
    (set! amb-cnt 0)
    r
  )
))

(define restore-amb2 (lambda (s)
  (set! last-amb        (list-ref s 0))
  (set! amb-state       (list-ref s 1))
  (set! amb-best-state  (list-ref s 2))
  (set! amb-best-scores (list-ref s 3))
  (set! amb-return-best (list-ref s 4))
  (set! amb-cnt         (list-ref s 5))
))

(defmacro with-amb2 args
 `(let ((oamb (save-amb2))
        (amb-result-r ,(cons 'begin args))
       )
    (restore-amb2 oamb)
    amb-result-r
  )
)

(define amb2 (lambda args
  (letrec* ((pamb last-amb)
            (mkey amb-cnt)
            (ambf (lambda (ar sk)
              (if (null? ar)
                  (begin
                    (hash-remove! amb-state mkey)
                    (if pamb
                        (begin
                          (set! amb-cnt mkey)
                          (pamb)
                        )
                        (if amb-best-state
                            (begin
                              (set! amb-return-best #t)
                              (sk (hash-ref amb-best-state mkey))
                            )
                            (int-err "Amb alternatives exhausted!")
                        )
                    )
                  )
                  (begin
                    (call/cc (lambda (k)
                      (set! last-amb k)
                      (hash-set! amb-state mkey (car ar))
                      (sk (car ar))
                    ))
                    (ambf (cdr ar) sk)
                  )
              )
            ))
           )
    (set! amb-cnt (inc mkey))
    (if amb-return-best 
        (hash-ref amb-best-state mkey)
        (call/cc (lambda (k) (ambf args k)))
    )
  )
))

(define amb2-cond (lambda (cnd)
  (if (not cnd)
      (if last-amb
          (last-amb)
          (int-err "False amb2-cond without any amb2s")
      )
  )
))

(define amb2-min (lambda scores
;;  (format #t "SCORES: ~a\n" scores)
  (letrec* ((cksc (lambda (sc1 sc2)
              (if (or (null? sc1) (null? sc2) (> (car sc1) (car sc2)))
                  #f
                  (or (< (car sc1) (car sc2)) (cksc (cdr sc1) (cdr sc2)))
              )
            ))
           )
    (if (not amb-return-best)
        (begin
          (if (or (not amb-best-state)
                  (cksc scores amb-best-scores)
              )
              (begin
                (set! amb-best-scores scores)
                (set! amb-best-state (hash-copy amb-state))
              )
          )
          (last-amb)
        )
    )
  )
))


(define inc (lambda (x) (+ x 1)))
(define dec (lambda (x) (- x 1)))

(define iptr (lambda (ptr dims)
  (if (null? ptr)
      0
     `(+ (- ,(car ptr) 1)
         (* ,(car dims)
            ,(iptr (cdr ptr) (cdr dims))
         )
      )
  )
))

(define iptr2 (lambda (ptr dims)
  (if (null? ptr)
      0
     `(+ ,(car ptr)
          (* ,(car dims)
             ,(iptr2 (cdr ptr) (cdr dims))
          )
      )
  )
))

(define bnd2ij (lambda (b)
  (cond ((eq? b 'x-) '(0 0))
        ((eq? b 'x+) '(0 1))
        ((eq? b 'y-) '(1 0))
        ((eq? b 'y+) '(1 1))
        ((eq? b 'z-) '(2 0))
        ((eq? b 'z+) '(2 1))
        (#t #f)
  )
))


(define iota1 (lambda (n)
  (if (< n 1)
      (list)
      (append (iota1 (- n 1)) (list (- n 1)))
  )
))

(define lamx (lambda (x) x))
(define lamxx (lambda x x))
(define lamn (lambda (n)
  (lambda x (list-ref x n))
))
(define lamln (lambda (n)
  (lambda (x) (list-ref x n))
))
(define lamapp (lambda (f)
  (lambda (x) (apply f x))
))
(define lamcon (lambda (c)
  (lambda x c)
))
(define lameq (lambda (n)
  (lambda (x) (eq? x n))
))
(define lamneq (lambda (n)
  (lambda (x) (not (eq? x n)))
))

(define pip (lambda (f1 . fo)
  (if (null? fo) f1 (lambda args (f1 (apply (apply pip fo) args))))
))

(define hash->assoc (lambda (h) (hash-map->list lamxx h)))
(define assoc->hash (lambda (a)
  (let ((h (make-hash-table)))
    (for-each
      (lambda (kv)
        (hash-set! h (car kv) (cadr kv))
      )
      a
    )
    h
  )
))
(define hash-keys (lambda (h) (hash-map->list (lamn 0) h)))
(define hash-vals (lambda (h) (hash-map->list (lamn 1) h)))

(define hash-reverse (lambda (h1)
  (let ((h2 (make-hash-table)))
    (hash-for-each
      (lambda (k v)
        (hash-set! h2 v k)
      )
      h1
    )
    h2
  )
))

(define hash-copy (lambda (h)
  (let ((h1 (make-hash-table)))
    (hash-for-each (lambda (k v) (hash-set! h1 k v)) h)
    h1
  )
))

;(define unspecified? (lambda (x)
;  (eq? (if #f 1) x)
;))

;(define list-set! (lambda (l p v)
;  (if (= p 0)
;      (set-car! l v)
;      (list-set! (cdr l) (- p 1) v)
;  )
;))

;;(define primitive-eval (lambda (v)
;;  (eval v);; cur-env
;;))

;(define zip (lambda ls
;  (if (or (null? ls)
;          (null? (car ls))
;      )
;      (list)
;      (cons (map car ls)
;            (apply zip (map cdr ls))
;      )
;  )
;))

;(define delete (lambda (v l)
;  (if (null? l)
;      (list)
;      (if (equal? v (car l))
;          (cdr l)
;          (cons (car l) (delete v (cdr l)))
;      )
;  )
;))

(define string-contains-only? (lambda (c s)
  (and (> (string-length s) 0)
       (null? (filter (lambda (x) (not (eq? c x))) (string->list s)))
  )
))

;(define string-join (lambda (l s)
;  (if (null? l)
;      ""
;      (string-append (car l)
;                     (if (null? (cdr l)) "" s)
;                     (string-join (cdr l) s)
;      )
;  )
;))

;(define string-map (lambda (f s)
;  (list->string (map f (string->list s)))
;))

(define string-has? (lambda (c s)
  (in-list? c (string->list s))
))

(define list-j12 (lambda (l)
  (let ((ll (length l)))
    (cond ((< ll 3) l)
          (#t (if (list? (car l))
                  (cons (append (car l) (list (cadr l))) (cddr l))
                  (cons (list (car l) (cadr l)) (cddr l))
              )
          )
    )
  )
))

(define list-before (lambda (l v)
  (if (null? l)
     '(()())
      (if (equal? (car l) v)
          (list '() (cdr l))
          (let ((r (list-before (cdr l) v)))
               (list (cons (car l) (car r)) (cadr r))
          )
      )
  )
))

(define list-split (lambda (l v)
  (if (null? l)
      (list)
      (let ((r (list-before l v)))
        (cons (car r) (list-split (cadr r) v))
      )
  )
))

;(define string-split (lambda (s c)
;  (map list->string (list-split (string->list s) c))
;))


(define roll (lambda (l)
  (append (cdr l) (list (car l)))
))

(define list-cut (lambda (l n)
  (if (eq? n 0)
      (cdr l)
      (cons (car l) (list-cut (cdr l) (- n 1)))
  )
))

(define list-ins (lambda (l n i)
  (if (eq? n 0)
      (cons i l)
      (cons (car l) (list-ins (cdr l) (- n 1) i))
  )
))


(define in-list? (lambda (v l)
   (member v l)
;  (assoc v (map (lambda (x) (list x 1)) l))
;  (and (not (null? l))
;       (or (equal? v (car l))
;           (in-list? v (cdr l))
;       )
;  )
;;;  (any (lambda (x) (equal? x v)) l)
))

(define remove-duplicates (lambda (l)
  (letrec* ((h (make-hash-table))
            (rmd (lambda (l)
              (if (null? l)
                  l
                  (if (hash-ref h (car l) #f)
                      (rmd (cdr l))
                      (begin
                        (hash-set! h (car l) #t)
                        (cons (car l) (rmd (cdr l)))
                      )
                  )
              )
            ))
           )
    (rmd l)
  )
))


(define replace-el (lambda (l k e)
  (if (eq? k 0)
    (cons e (cdr l))
    (cons (car l) (replace-el (cdr l) (- k 1) e))
  )
))

(define int-err (lambda (str . args)
  (apply
    format
    (cons #t (cons (string-append "Internal error: " str "\n") args))
  )
  (display (backtrace))
  (error #f #f)
;;  (exit)
))


(define obj-find-el (lambda (v t)
  (find (lambda (x) (and (list? x) (not (null? x)) (eq? (car x) t))) v)
))


(define syms-strs (list))
(define syms-ints (list))

(define sym->str (lambda (s)
  (let ((ss (assoc s syms-strs)))
    (if ss
        (cadr ss)
        (let ((sss (symbol->string s)))
          (set! syms-strs (cons (list s sss) syms-strs))
          sss
        )
    )
  )
))

(define mk-worm (lambda (n w l)
  (apply string-append
    (letrec*
      ((w1 (lambda (x)
         (if (= x w)
            '()
             (cons (let* ((tofs (remainder
                                  (- (max l (remainder n (* l 2))) l)
                                  (+ w l)
                                )
                          )
                          (hofs (remainder
                                  (+ 1 
                                     (min l (remainder n (* l 2)))
                                  )
                                  (+ w l)
                                )
                          )
                          (x1 (+ 2 (- x (* l (floor (/ n (* l 2)))))))
                         )
                     (cond ((= x1 tofs) "o")
                           ((= x1 hofs) "@")
                           ((and (> x1 tofs) (< x1 hofs)) "O")
                           (#t ".")
                     )
                   )
                   (w1 (+ x 1))
             )
         )
       ))
       (n5 (remainder n 5))
      )
      (cons (string-append "[" (substring "|/-\\|" n5 (+ n5 1)) "] ")
            (w1 0)
      )
    )
  )
))

(define worm-len     5)
(define worm-road   30)

(define dot-sym
  (map (lambda (x) (mk-worm x worm-road worm-len))
       (iota1 (+ (* worm-road (floor (/ worm-len 2))) worm-len 2))
  )
)

(define last-dot 0)
(define last-dot-l 0)
(define last-dot-time 0)

(define dot-mtx (make-mutex))

(define shdot (lambda ()
  (if (> (- (tms:clock (times)) last-dot-time)
         (* 0.25 internal-time-units-per-second)
      )
      ;(wmt dot-mtx
        (begin
          (for-each (lambda (i) (display "\b")) (iota1 last-dot-l))
          (format #t "~a" (list-ref dot-sym last-dot))
          (flush-output-port (current-output-port))
          (set! last-dot-l (string-length (list-ref dot-sym last-dot)))
          (set! last-dot (if (< last-dot (- (length dot-sym) 2)) (+ last-dot 1) 0))
          (set! last-dot-time (tms:clock (times)))
        )
      ;)
  )
))

)
